{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}

module Language.Dependencies.Adaptors.Haskell where

-- container
import Data.Tree (Tree(Node,rootLabel))

-- local imports
import Language.Dependencies.Language as L

import Language.Haskell.Exts.Annotated

import Language.Dependencies.Term2tree (data2tree)
import Generics.MultiRec.Languages.Haskell

haskellexts = Language 
  { L.name         = "Haskell" 
  , syntax       = "Haskell" 
  , exts         = [".hs"] 
  , L.parse        = parHaskell
  , toTree       = (data2tree TheModule :: (Module SrcSpanInfo) -> Tree String)
  , srcLoc       = toSrcLoc
  , adjustSrcLoc = Nothing
  , srcLoctype   = (Coordinate undefined undefined)
  , typerep = Just TheModule
  }
    
parHaskell :: String -> Either Error (Module SrcSpanInfo)
parHaskell s =
  case parseModule s of
    ParseOk t   -> Right t
    ParseFailed (SrcLoc _ l c) m -> 
      Left $ ErrLocation (Coordinate (l,c) (l,c)) m

adjust :: SrcLoc -> SrcLoc
adjust sl = sl { srcLine = 1+srcLine sl}


toSrcLoc :: Tree String -> [L.Loc]
toSrcLoc (Node "SrcSpanInfo" ((Node "SrcSpan" cs):_)) = 
  [Coordinate (l1,c1) (l2,c2)] 
  where to = rootLabel . (cs !!)
        l1 = read (to 1)::Int
        c1 = read (to 2):: Int
        l2 = read (to 3)::Int
        c2 = read (to 4):: Int
toSrcLoc _        = [] 
